SuperHack/SuperHack CD.bin/CODING/DEMOS/CIVAX6.ZIP/COOL2.PAS

Pascal/Delphi Source File | 1995-10-13 | 37.0 KB | 1,560 lines

 {$N+,G+}

program COOL_BBS_realy_good_intro;

uses dos,pic1,fnt1,crt;


Type

    rgb     = array [1..3] of byte;
    palet   = array [0..255] of rgb;
    TabType = array [0..255] of shortint;
    Virtu   = Array [1..64000] of byte;            { The size of our Virtual Screen }
    VirtPtr = ^Virtu;                              { Pointer to the virtual screen }

Const

     Xc                      =  0;
     Yc                      =  0;
     Zc                      =  300;
     Nofpoints               =  7;
     Nofpolys                =  5;
     PhiX          :    byte =  0;
     Phiy          :    byte =  0;
     Phiz          :    byte =  0;
     zoff          : Integer =  200;
     xoff          : Integer =  160;
     yoff          : Integer =  100;
     vseg                    =  $A000;             {video segment}
     VekMax                  =  10;
     Xstep                   =  -3;
     Ystep                   =   1;
     Zstep                   =  -2;

     Point : array [0..Nofpoints,0..2] of integer =
            (
             ( -50 ,  50 ,  50 ), {up}
             ( -50 ,  50 , -50 ),
             (  50 ,  50 , -50 ),
             (  50 ,  50 ,  50 ),
             ( -50 , -50 ,  50 ), {down}
             ( -50 , -50 , -50 ),
             (  50 , -50 , -50 ),
             (  50 , -50 ,  50 )
            );

     Polyst : Array [0..Nofpolys,0..3] of byte =
              (  {up}     {down}     {in}
               (1,0,3,2),(5,4,7,6),(1,5,6,2),
               {out}    {left}    {right}
               (0,4,7,3),(1,5,4,0),(2,6,7,3)
              );

     Polcols : Array [0..Nofpolys] of byte = ( 20,22,24,26,28,30 );

var

   PInd                 : Array [0..Nofpolys] of integer;
   Polyz                : array [0..Nofpolys] of Integer;
   I                    : integer;
   SinTab               : TabType;
   j,shaq               : Byte;
   virscr               : VirtPtr;
   s,o,vad              : word;
   plg                  : array [1..4,1..2] of integer;
   ch                   : char;
   pc                   : Integer;
   polyx,polyy          : array [0..2] of word;
   px,py,pz             : array [0..nofpoints] of integer;
   X,Y,Z,X1,Y1,Z1       : integer;
   F                    : File;
   P                    : Pointer;
   Pal                  : Palet;
{---------------------------------------------------}

type

       Palette    = Array[0..255,1..3]       of Byte;
       Str80 = String[80];
       FONT_LETTER = array[0..15] of byte;
       FONT_ARRAY = array[0..255] of font_letter;


label jm1;    {was in use in some of the plays}

const           {this word is very deep.  Lets stop n' think
                 about it for a while.}

      BITMAP:array[0..7] of byte = (128,64,32,16,8,4,2,1);
      LINEWIDTH:WORD=320;
      SHADOW:boolean=false; {false;}
      SHADOWCOL:byte=37;
      UNDERLINE:boolean=false;
      UNDERCOL:byte=0;
      PROPOR:boolean=true;
      NODRAWCOL:byte = 0;


  range = 35;   {What, finished thinking?!}
  rang = 17;

var
     font1     : font_array;
 Pic1Pal:palette;
 Pic1Seg,Pic1Ofs:Word;
  eee:byte;
  TOP,BOTTOM,ii:WORD;
  imb,yay,counter,mult:byte;
  sins : array[0..range] of shortint;
  lin : word;
  orr:boolean;


{$M 65520, 0, 655360}


const
  MaxX = 319;
  MaxY = 199;
  HalfX = MaxX div 2;
  HalfY = MaxY div 2;
  ShadeRad : integer = 8;
  ColBackGd : integer = 28;
  Pal2Rot : boolean = false;
  deltarad : boolean = false;

type
  ColorValue = record
    red, green, blue: byte;
  end;

  PaletteType = array [0..255] of ColorValue;

  pointrec3d = record
    x, y, z : integer
  end;
  pointarray3d = array [1..10] of pointrec3d;

  pointrec2d = record
    x, y, z, r, c : integer
  end;
  pointarray2d = array [1..10] of pointrec2d;

  buffrec = record
    x, y : integer
  end;
  buffarray = array [1..10] of array [1..10] of buffrec;

var
  palee   : palettetype;
  pt    : pointarray3d;
  p2    : pointarray2d;
  ptend : integer;
  b     : buffarray;
  bobbing, SBob : boolean;
  oldclockvec : procedure;
  putlinepixel : procedure (x, y : integer; color : byte);
  first, second : ColorValue;
  pal2 : palettetype;
  d_rads : array [1..5] of integer;





TYPE HSC_Song = RECORD
                  Song     : POINTER;
                  SongSize : WORD;
                  FileName : STRING;
                  SongOK   : BOOLEAN;
                END;
     HSC_Info = ARRAY [0..39] OF BYTE;

VAR Musik   : HSC_Song;
    Info    : HSC_Info;
    HeadPtr : WORD ABSOLUTE $40:$1A;
    TailPtr : WORD ABSOLUTE $40:$1C;

{$F+}
{$L HSCOBJ.OBJ}
PROCEDURE _HscPlayer; EXTERNAL;

PROCEDURE StartMusic (Song : POINTER; Polling, OldIRQ : BOOLEAN); ASSEMBLER;
  ASM
    MOV  AH,0
    MOV  BL,Polling
    MOV  BH,OldIRQ
    CMP  BH,1
    JE   @Invert
    MOV  BH,1
    JMP  @GoOn
  @Invert:
    XOR  BH,BH
  @GoOn:
    LES  SI,DWORD PTR Song
    CALL _HscPlayer
  END;

PROCEDURE PollMusic; ASSEMBLER;
  ASM
    MOV  AH,1
    CALL _HscPlayer
  END;

PROCEDURE StopMusic; ASSEMBLER;
  ASM
    MOV  AH,2
    CALL _HscPlayer
  END;

FUNCTION  DetectAdlib (SuggestedPort : WORD) : WORD; ASSEMBLER;
  ASM
    MOV  AH,4
    MOV  BX,SuggestedPort
    CALL _HscPlayer
    JNC  @GoOn
    MOV  AX,0FFh
  @GoOn:
  END;

PROCEDURE ToggleRasterBar; ASSEMBLER;
  ASM
    MOV  AH,5
    CALL _HscPlayer
  END;

PROCEDURE SetUserIRQ (Link : BOOLEAN; Routine : POINTER); ASSEMBLER;
  ASM
    PUSH DS
    MOV  AH,6
    MOV  BL,Link
    LDS  DX,DWORD PTR Routine
    CALL _HscPlayer
    POP  DS
  END;

PROCEDURE GetPlayerState (VAR Destination); ASSEMBLER;
  ASM
    MOV  AH,7
    LES  SI,DWORD PTR Destination
    CALL _HscPlayer
  END;

Procedure HSC001; external;
{$L HSC1.OBJ}

PROCEDURE LoadSong (VAR Dest : HSC_Song);
  VAR F : FILE;
  BEGIN
        BEGIN
          Dest.SongSize := 10804;
          GETMEM (Dest.Song,Dest.SongSize);
          Move(Mem[Seg(HSC001):Ofs(HSC001)],Mem[Seg(Dest.Song^):Ofs(Dest.Song^)],Dest.SongSize);
          Dest.SongOK := TRUE;
        END
  END;

PROCEDURE ClearSong (VAR Dest : HSC_Song);
  BEGIN
    Dest.SongOK := FALSE;
    FREEMEM (Dest.Song,Dest.SongSize);
    Dest.SongSize := 0
  END;










{---------------------------------------------------}


procedure putpixel(x,y:word;col:byte); assembler;
var add:word;
 asm
        mov ax,y
        mul LineWidth
        add ax,x
        mov di,ax

        mov bx,0a000h              {                                    }
        mov es,bx                  { * set ES:DI to video screen memory }
        mov cl,col                 { * set cl to the color              }
        mov es:[di],cl             { * write the color to the screen    }
@nodraw:
end;






procedure EatKeypress;

  var
    ch : char;

  begin
    if keypressed then
      begin
        ch := readkey;
        if ch in [#17, #24, #27] then halt;   { Ctrl-Q, Ctrl-X, Escape key }
        if ch = #0 then
          begin
            ch := readkey;
            if ch in [#16, #45, #68] then halt;  { Alt-Q, Alt-X, F10 }
          end
      end;
  end;


Function ISqrt(a:word):integer;
begin
  Isqrt:=round(sqrt(a));
end;

procedure ModeVGA; assembler;

  asm
    mov ax, 0013h
    int 10h
  end;


function getpixel (a, b : integer) : byte;

  begin
    GetPixel := mem[$A000:word(320*b+a)]
  end;

procedure Swap (var a, b : integer);

  var
    t : integer;

  begin
    t := a;
    a := b;
    b := t
  end;

procedure HLiner (x1, x2, y : integer; color : byte);

  begin
    if x2 < x1 then
      swap(x1,x2);
    if x1 < 0 then x1 := 0;
    if x1 > MaxX then x1 := MaxX;
    if x2 < 0 then x2 := 0;
    if x2 > MaxX then x2 := MaxX;
    if (y > 0) and (y < MaxY) then
      fillchar(mem[$A000:x1+y*320],x2-x1+1,color);
  end;

procedure VLiner (x, y1, y2 : integer; color : byte);

{ Draws a vertical line.  Apple ][e BASIC command. }

  var
    y : integer;

  begin
    if y1 > y2 then swap (y1, y2);
    for y := y1 to y2 do
      PutPixel (x, y, Color)
  end;

Procedure Line(x1,y1,x2,y2:integer;color:byte); assembler;
var
  diagonal_x_increment,
  diagonal_y_increment,
  short_distance,
  straight_x_increment,
  straight_y_increment,
  straight_count,
  diagonal_count:integer;
asm
  mov ax, $a000 { Set up segment for output }
  mov es,ax
  mov cx,1 { Set initial increments for each pixel position }
  mov dx,1
  mov di,y2 { Calculate Vertical distance }
  sub di,y1
  jge @keep_y
  neg dx
  neg di
@Keep_Y:
  mov diagonal_y_increment,dx
  mov si,x2 { Calculate horizontal distance }
  sub si,x1
  jge @keep_x
  neg cx
  neg si
@Keep_X:
  mov diagonal_x_increment,cx
  cmp si,di { Figure whether straight segments are horizontal or vertical }
  jge @horz_seg
  mov cx,0
  xchg si,di
  jmp @Save_Values
@Horz_seg:
  mov dx,0
@Save_values:
  mov short_distance,di
  mov straight_x_increment,cx
  mov straight_y_increment,dx
  mov ax,short_distance { Calculate adjustment factor }
  shl ax,1
  mov straight_count,ax
  sub ax,si
  mov bx,ax
  sub ax,si
  mov diagonal_count,ax
  mov cx,x1 { prepare to draw the line }
  mov dx,y1
  inc si
  mov al,color
@MainLoop: { Now draw the line }
  dec si
  jz  @line_finished
  { Plot Pixel }
  push ax
  push bx
  push cx
  push dx
  push si

  push cx
  push dx
  push ax
  call putlinepixel

  pop  si
  pop  dx
  pop  cx
  pop  bx
  pop  ax
  { End Plot Pixel }
  cmp bx,0
  jge @diagonal_line
  add cx,straight_x_increment { Draw Stright Line Segments }
  add dx,straight_y_increment
  add bx,straight_count
  jmp @MainLoop
@Diagonal_line: { Draw Diagonal Line Segments }
  add cx,diagonal_x_increment
  add dx,diagonal_y_increment
  add bx,diagonal_count
  jmp @MainLoop
@Line_Finished:
end;

procedure fillcircle (x_center, y_center, radius, color : word);

  var
    x,y,r2:integer;

  begin
    if radius=0 then exit;
    r2:=radius*radius;
    x:=0;
    y:=radius;
    repeat
      hliner(x_center-x,x_center+x,y_center-y, color);
      hliner(x_center-x,x_center+x,y_center+y, color);
      hliner(x_center-y,x_center+y,y_center-x, color);
      hliner(x_center-y,x_center+y,y_center+x, color);
      inc(x);
      y:=isqrt(r2-x*x);
    until x>y;
  end;

procedure ShadeBobCirc (x_center, y_center, radius : word; sb : boolean);

  var
    x,y,r2:integer;

  procedure ahline (x, x2, y : integer);

   { Anti - hline shadebob }

    var
      xloop, c : integer;

    begin
      for xloop :=  x to x2 do
        begin
          c := getpixel (xloop, y);
          dec (c);
          if c < 0 then c := 140;
          if bobbing and (c < ColBackGd) then c := ColBackgd;
          putpixel (xloop, y, c);
        end;

    end;

  procedure hliner (x, x2, y : integer);

    var
      xloop, c : integer;

    begin
      for xloop :=  x to x2 do
        begin
          c := getpixel (xloop, y);
          inc (c);
          if bobbing and (c > 140) then c := ColBackGd
            else
          if c > 140 then c := 0;
          putpixel (xloop, y, c);
        end;
    end;

  begin
    if radius=0 then exit;
    r2:=radius*radius;
    x:=0;
    y:=radius;
    repeat
      if sb then
        begin
          hliner(x_center-x,x_center+x,y_center-y);
          hliner(x_center-x,x_center+x,y_center+y);
          hliner(x_center-y,x_center+y,y_center-x);
          hliner(x_center-y,x_center+y,y_center+x);
        end
      else
        begin
          ahline(x_center-x,x_center+x,y_center-y);
          ahline(x_center-x,x_center+x,y_center+y);
          ahline(x_center-y,x_center+y,y_center-x);
          ahline(x_center-y,x_center+y,y_center+x);
        end;
      inc(x);
      y:=isqrt(r2-x*x);
    until x>y;
  end;

procedure getdata;

  var
    loop : integer;

  begin
    pt [1].x := -20;
    pt [1].y := 0;
    pt [1].z := 0;
    pt [2].x := 0;
    pt [2].y := 0;
    pt [2].z := 20;
    pt [3].x := 20;
    pt [3].y := 0;
    pt [3].z := 0;
    pt [4].x := 0;
    pt [4].y := 0;
    pt [4].z := -20;
    pt [5].x := 0;
    pt [5].y := 20;
    pt [5].z := 0;

    for loop := 1 to 10 do
      begin
      end;
  end;

function rad (a : real) : real;

  begin
    rad := a * pi / 180
  end;

procedure rotatearray (lrtheta, udtheta, circtheta : real;
  xshift, yshift, zoom: integer);

  var
    xa, ya, ca, e, f,
    cud, sud, clr, slr, cc, sc : real;
    loop : integer;

  begin
    cud := cos (udtheta);
    sud := sin (udtheta);
    clr := cos (lrtheta);
    slr := sin (lrtheta);
    cc := cos (circtheta);
    sc := sin (circtheta);
    for loop := 1 to ptend do
      begin
        xa := (clr * pt [loop].x) - (slr * pt [loop].z);
        ca := (slr * pt [loop].x) + (clr * pt [loop].z);
        e := (cc * xa) + (sc * pt [loop].y);
        ya := (cc * pt [loop].y) - (sc * xa);
        p2 [loop].z := round ((cud * ca - sud * ya) * zoom);
        f := (sud * ca) + (cud * ya);
        p2 [loop].x := round (e * zoom + xshift);
        p2 [loop].y := round (f * zoom + yshift);
      end;
    for loop := 10 downto 2 do
      b [loop] := b [loop - 1];
    for loop := 1 to ptend do
      begin
        b [1, loop].x := p2 [loop].x;
        b [1, loop].y := p2 [loop].y;
      end
  end;

procedure putdata;

  var
    loop, loop2, loop3, r, dy, dx, y, x : integer;

  begin
    loop := 0;
    dy := 1;
    dx := 1;
    y := halfy;
    x := halfx;
    while not keypressed do
      begin
    inc (x, dx);
    inc (y, dy);
    if (dx = 1) and (x > MaxX - 50) then dx := -1;
    if (dx = -1) and (x < 50) then dx := 1;
    if (dy = 1) and (y > MaxY - 50) then dy := -1;
    if (dy = -1) and (y < 50) then dy := 1;

    rotatearray (rad (loop), rad (loop), 0, x, y, 2);

    for loop2 := 1 to ptend do
      ShadeBobCirc (b [1, loop2].x, b [1, loop2].y, 8, true);

    for loop2 := 1 to ptend do
      if (b [10, loop2].x <> 0) or (b [10, loop2].x <> 0)
        or (b [10, loop2].y <> 0) or (b [10, loop2].y <> 0) then
          ShadeBobCirc (b [10, loop2].x, b [10, loop2].y, 8, false);

    inc (loop, 10);
    if loop = 360 then loop := 0;

    end;
  end;

procedure ShadeBob (x1, y1, x2, y2 : integer);

  var
    x, y : integer;

  begin
    x := x1;
    y := y1;
    ShadeBobCirc (x, y, shaderad, SBob);
    while (x <> x2) or (y <> y2) do
      begin
        if x > x2 then dec (x) else if x < x2 then inc (x);
        if y > y2 then dec (y) else if y < y2 then inc (y);
        ShadeBobCirc (x, y, shaderad, SBob)
      end;
    EatKeyPress;
  end;

procedure ShowPhone;

  var
    tempnum, tempnum2, tempnum3 : ColorValue;
    loopy : integer;

  begin
    shaderad := 2;

    { 972-7-731239 }

{}  ShadeBob (20,150, 40,150);
    ShadeBob (40,150, 40,170);
    ShadeBob (40,170, 20,170);
    ShadeBob (40,160, 20,160);
    ShadeBob (20,160, 20,150);{}      {9}
{}  ShadeBob (45,150, 65,150);
    ShadeBob (65,150, 55,170);{}      {7}
{}  ShadeBob (70,150, 90,150);
    ShadeBob (90,150, 90,160);
    ShadeBob (90,160, 70,160);
    ShadeBob (70,160, 70,170);
    ShadeBob (70,170, 90,170);{}      {2}
{}  ShadeBob (99,160,108,160);{}      {-}
{}  ShadeBob (110,150,130,150);
    ShadeBob (130,150,120,170);{}     {7}
{}  ShadeBob (135,160,145,160);{}     {-}
    shaderad:=3;
{}  ShadeBob (150,145,170,145);
    ShadeBob (170,145,160,175);{}     {7}
{}  ShadeBob (180,145,200,145);
    ShadeBob (200,145,200,175);
    ShadeBob (200,175,180,175);
    ShadeBob (180,160,200,160);{}     {3}
{}  ShadeBob (210,145,210,175);{}     {1}
{}  ShadeBob (220,145,240,145);
    ShadeBob (240,145,240,160);
    ShadeBob (240,160,220,160);
    ShadeBob (220,160,220,175);
    ShadeBob (220,175,240,175);{}     {2}
{}  ShadeBob (250,145,270,145);
    ShadeBob (270,145,270,175);
    ShadeBob (270,175,250,175);
    ShadeBob (250,160,270,160);{}     {3}
{}  ShadeBob (300,160,280,160);
    ShadeBob (280,160,280,145);
    ShadeBob (280,145,300,145);
    ShadeBob (300,145,300,175);
    ShadeBob (300,175,280,175);{}     {9}

  end;














{-----------------}

Procedure sc(col,r,g,b:byte);     {Set color routine.  Isn't it boring?!}
begin
     port[$3c8]:=col;
     port[$3c9]:=r;
     port[$3c9]:=g;
     port[$3c9]:=b;
end;



Procedure putpal(pal:palet);      {Put the Palette.  Gee, what a thrill!}
var
   i:byte;
begin
     for i:=0 to 255 do
         sc(i,pal[i,1],pal[i,2],pal[i,3]);
end;


Procedure rotpal(fp,tp:byte;var pal:palet);   {Cycle the colors. }
var
   r:rgb;
begin
     move(pal[fp,1],r[1],3);
     move(pal[fp+1,1],pal[fp,1],(tp-fp)*3);
     move(r[1],pal[tp,1],3);
     PUTPAL(PAL);
end;



Procedure UpdPalette(Pallt:Palette);
Var
 AA:Word;
Begin
 For AA:=0 to 255 do SC(AA,Pallt[AA,1],Pallt[AA,2],Pallt[AA,3]);
End;

   {---------------------}

Procedure Delay(ms : Word); Assembler;
Asm {machine independent Delay Function}
  mov ax, 1000;
  mul ms;
  mov cx, dx;
  mov dx, ax;
  mov ah, $86;
  int $15;
end;

Function KeyPressed : Boolean;
Var
  IsThere : Byte;
begin
  Inline(
    $B4/$0B/               {    MOV AH,+$0B         ;Get input status}
    $CD/$21/               {    INT $21             ;Call Dos}
    $88/$86/>ISTHERE);     {    MOV >IsThere[BP],AL ;Move into Variable}
  KeyPressed := (IsThere = $FF);
end;

Function ReadKey : Char;  { Replacement For Crt.ReadKey }
Var
  chrout : Char;
begin
  {  ;Just like ReadKey in Crt Unit}
  Inline(
  $B4/$07/               {  MOV AH,$07          ;Char input w/o echo}
  $CD/$21/               {  INT $21             ;Call Dos}
  $88/$86/>CHROUT);      {  MOV >chrout[bp],AL  ;Put into Variable}
(*  if CheckBreak and (chrout = #3) then  {if it's a ^C and CheckBreak True}
  {then execute Ctrl_Brk}
    Inline($CD/$23);           {     INT $23}  *)
  ReadKey := chrout;                    {else return Character}
end;

Procedure wobbler(top,bottom,mult:byte);      {Here is the fuck'n routine!}
begin
  lin := 320 * yay;
  move(ptr(s,o+lin)^,mem[$a000:lin + sins[imb] +1],320 - sins[imb] -2);
  inc(imb);
if imb > range then imb := 0;
  inc(yay);
if yay > bottom then
begin
  yay := top;
    if counter > 1 then dec(counter,2) else counter := range;
  imb := counter
end;
{
inc(eee);
if eee=7 then begin
               eee:=0;
               rotpal(1,175,pal);
              end;
 }
end;









Procedure SetUpVirtual; { This sets up the memory needed for the virtual screen }
BEGIN
  GetMem (VirScr,64000);
  vad := seg (virscr^);
END;

Procedure ShutDown; { This frees the memory used by the virtual screen }
BEGIN
  FreeMem (VirScr,64000);
END;

procedure flip(source,dest:Word); { This copies the entire screen at "source" to destination }
begin
  asm
    push    ds
    mov     ax, [Dest]
    mov     es, ax
    mov     ax, [Source]
    mov     ds, ax
    xor     si, si
    xor     di, di
    mov     cx, 32000
    rep     movsw
    pop     ds
  end;
end;

procedure Calcsinus(var SinTab : TabType);
var
   I : byte;
begin
     for I := 0 to 255 do
         SinTab[I] := round(sin(2*I*pi/255)*127);
end;

Procedure Hline (x1,x2,y:word;col:byte;where:word;yn:boolean); assembler;
asm
  push  es
  push  ds
  mov   ax,vad
  mov   es,ax
  mov   ax,Where
  mov   ds,ax
  cld

  mov   ax,y
  mov   di,ax
  shl   ax,8
  shl   di,6
  add   di,ax
  add   di,x1

  mov   si,di
  mov   al,col
  mov   ah,al
  shl   ax,16
  mov   al,col
  mov   ah,al
  mov   cx,x2
  sub   cx,x1

  mov   bx,4
  shr   cx,1
  jnc   @start

  cmp   yn,1
  je    @tr
  stosb
  jmp   @start

@tr:

  movsb

@Start :

  cmp   yn,1
  je    @tru
  rep   stosw
  jmp   @stp

@tru:

  rep   movsw

@stp:
     pop ds
     pop es
end;

PROCEDURE FillPolygon(Size:Integer; VAR P1; C:Byte;where:word;yn:boolean);
TYPE
    Vektor=RECORD
                 X,Y,XMax,DX,DY,DZ,Z,Spalte:Integer;
           END;
    VekPoly=ARRAY[1..VekMax,1..2,1..2] OF Integer;
VAR
   P:ARRAY[1..VekMax,1..2] OF Integer ABSOLUTE P1;
   Sp:VekPoly;
   NF:Boolean;
   V:ARRAY[1..VekMax] OF Vektor;
   S:ARRAY[1..2*VekMax] OF Integer;
   I,J,K,N,SX,YRMin,YRMax,YR,XMin,YMin,YMax,I2:Integer;
BEGIN
     IF Size>VekMax THEN
        Exit;
     K:=1;
     FOR I:=1 TO Size DO
     BEGIN
          Sp[K,1,1]:=P[I,1];
          Sp[K,1,2]:=P[I,2];
          IF I=Size THEN
          BEGIN
               Sp[K,2,1]:=P[1,1];
               Sp[K,2,2]:=P[1,2];
          END
          ELSE
          BEGIN
               Sp[K,2,1]:=P[I+1,1];
               Sp[K,2,2]:=P[I+1,2];
          END;
          IF Sp[K,2,2]-Sp[K,1,2]<0 THEN
          BEGIN
               J:=Sp[K,2,1];
               Sp[K,2,1]:=Sp[K,1,1];
               Sp[K,1,1]:=J;
               J:=Sp[K,2,2];
               Sp[K,2,2]:=Sp[K,1,2];
               Sp[K,1,2]:=J;
          END;
          Inc(K);
     END;
     YRMin:=199;
     YRMax:=0;
     FOR K:=1 TO Size DO
         FOR I:=1 TO 2 DO
         BEGIN
              IF Sp[K,I,2]>YRMax THEN
                 YRMax:=Sp[K,I,2];
              IF Sp[K,I,2]<YRMin THEN
                 YRMin:=Sp[K,I,2];
         END;
     IF YRMin<0 THEN
        YRMin:=0;
     IF YRMax>199 THEN
        YRMax:=199;
     FOR K:=1 TO Size DO
         WITH V[K] DO
         BEGIN
              XMin:=Sp[K,1,1];
              YMin:=Sp[K,1,2];
              XMax:=Sp[K,2,1];
              YMax:=Sp[K,2,2];
              DX:=Abs(XMin-XMax);
              DY:=Abs(YMin-YMax);
              X:=XMin;
              Y:=YMin;
              IF XMin<XMax THEN
                 Z:=1
              ELSE Z:=-1;
              IF DX>DY THEN
                 I2:=DX
              ELSE I2:=DY;
              DZ:=I2 DIV 2;
              Spalte:=XMin;
         END;
     FOR YR:=YRMin TO YRMax DO
     BEGIN
          N:=0;
          FOR K:=1 TO Size DO
              IF ((Sp[K,1,2]<=YR) AND (YR<SP[K,2,2])) OR ((YR=YRMax) AND (YRMax=Sp[K,2,2]) AND (YRMax<>Sp[K,1,2])) THEN
              BEGIN
                   WITH V[K] DO
                   BEGIN
                        Inc(N);
                        S[N]:=X;
                        SX:=X;
                        REPEAT
                              IF DZ<DX THEN
                              BEGIN
                                   DZ:=DZ+DY;
                                   X:=X+Z;
                              END;
                              IF DZ>=DX THEN
                              BEGIN
                                   DZ:=DZ-DX;
                                   Inc(Y);
                              END;
                              IF Y=YR THEN
                                 SX:=X;
                              Inc(Spalte,Z);
                        UNTIL (Y>YR) OR (Spalte=XMax);
                        Inc(N);
                        S[N]:=SX;
                   END;
              END;
          FOR I:=2 TO N DO
              FOR K:=N DOWNTO I DO
                  IF S[K-1]>S[K] THEN
                  BEGIN
                       J:=S[K-1];
                       S[K-1]:=S[K];
                       S[K]:=J;
                  END;
          K:=1;
          WHILE K<=N DO
          BEGIN
               IF S[K]<0 THEN
                  S[K]:=0;
               IF S[K+3]>319 THEN
                  S[K+3]:=319;
               HLine(S[K],S[K+3],YR,C,where,yn);
               K:=K+4;
          END;
     END;
END;

procedure QuickSort( Lo, Hi: Integer);
 procedure Sort(l, r: Integer);
 var
    i, j, x, y: integer;
 begin
      i := l;
      j := r;
      x := polyz[(l+r) DIV 2];
      repeat
            while polyz[i] < x do i := i + 1;
            while x < polyz[j] do j := j - 1;
            if i <= j then
            begin
                 y := polyz[i];
                 polyz[i] := polyz[j];
                 polyz[j] := y;
                 y := Pind[i];
                 Pind[i] := Pind[j];
                 Pind[j] := y;
                 i := i + 1;
                 j := j - 1;
            end;
      until i > j;

      if l < j then Sort(l, j);
      if i < r then Sort(i, r);
 end;

begin
      Sort(Lo,Hi);
end;

function Sinus(Idx : byte) : integer;
begin
     Sinus := SinTab[Idx];
end;

function Cosinus(Idx : byte) : integer;
begin
     Cosinus := SinTab[(Idx+192) mod 255];
end;







var
     FntEs,FntBp,fnt1seg,fnt1ofs:Word;
     FontPal1  : Palet;
     MyBMfnt1  : Pointer;


Procedure WrBitMapFnt(FntPtr:Pointer;Xsize,Ysize:Byte;XX,YY:Word;DStr:String);
Var
 AA,BB,CC,OffST:Word;
 FntSeg,FntOfs,Ofs1:Word;
 AscV:Byte;
Begin
 FntSeg:=Seg(Fnt001);
 FntOfs:=Ofs(Fnt001);
 For CC:=1 to Length(Dstr) do
 Begin
  AscV:=Ord(Dstr[CC]);
  If (AscV<32) or (AscV>90) then AscV:=32;
  For AA:=1 to Ysize do
  Begin
   For BB:=1 to Xsize do
   Begin
    Ofs1:=((Xsize*Ysize)*(AscV-32)) + (((AA-1)*Xsize)+(BB-1));
    If Mem[FntSeg:FntOfs+Ofs1]<>0 then begin
{     Mem[$A000:OffST]:=Mem[FntSeg:FntOfs+Ofs1];}
     Mem[seg(p^):OffST]:=Mem[FntSeg:FntOfs+Ofs1];
     end;
    OffST:=(YY+AA-1)*320+(XX+BB-1);
   End;
  End;
  Inc(XX,Xsize);
 End;
End;

Procedure ClrBOX(x,y,X1,Y1:word);
Var
  I,I1 : Integer;

begin
 For I:=x to x1 do
  for I1:=y to y1 do
  begin
   mem[seg(p^):I+(I1*320)]:=0;
  end;

end;
procedure wol(x,y,al:WORD;str:CHAR);
begin
 x:=x*16+al;
 WrBitMapFnt(MyBMfnt1,16,16,x,y,str);
end;

procedure showlines(bl,al:byte;str:string);
var x:byte;
begin
For x:=1 to Length(str) do
wol(x,bl,al,str[x]);
END;


procedure FontPal(base,gchn,bchn:byte);
var cx:byte;
begin
 for cx:=1 to 15 do
 sc(cx,base,63-(gchn*cx),63-(bchn*cx));
end;




  var
    loop : integer;
    font : array [0..255, 0..15] of byte;

  Procedure LoadROMFont;

    var
      f8x8ofs, f8x8seg : word;

    begin
      asm
        push bp
        mov ah,11h
        mov al,30h
        mov bh,06h
        int 10h
        mov ax,bp
        pop bp
        mov f8x8ofs,ax
        mov f8x8seg,es
      end;
      move(mem[f8x8seg:f8x8ofs],font,256*16)
    end;

  Procedure GrWrite (line : string; x, y : integer; forecolor : byte);

    var
      tx,ty:word;
      i:byte;

    begin
      for i:=1 to length(line) do
        for ty:=0 to 15 do
          for tx:=0 to 7 do
            if font[ord(line[i]),ty] and ($80 shr tx)<>0 then
              putpixel(x+tx+(i-1)*10, y+ty, forecolor)
    end;

  procedure CenterText (str : string; y : integer; color : byte);

    begin
      GrWrite (Str, HalfX - ((length (Str) * 10) div 2), y, Color)
    end;




var vvv:word;
    VVX:INTEGER;
    PART,cor:BYTE;

begin
 Move(Mem[Seg(PIC001):(Ofs(PIC001)+10)],Pic1Pal[0],768);
 Move(Mem[Seg(PIC001):(Ofs(PIC001)+10)],Pal[0],768);
 Pic1Seg:=Seg(PIC001);Pic1Ofs:=Ofs(PIC001)+778;

    part:=1;
     calcsinus(Sintab);

     asm
        mov ax,13h
        int 10h
     end;

        LoadSong (Musik);
              StartMusic(Musik.Song,FALSE,TRUE);



     getmem(p,64000);
 updpalette(pic1pal);
 Move(Mem[Pic1Seg:Pic1Ofs],Mem[$A000:0],64000);
 Move(Mem[Pic1Seg:Pic1Ofs],p^,64000);
 move(p^,mem[$a000:0],64000);
 loadROMfont;
      FontPal(30,4,2);

     SetUpVirtual;

     move(p^,virscr^,64000);

     fillchar(px,sizeof(px),0);
     fillchar(py,sizeof(py),0);
     fillchar(pz,sizeof(py),0);
     shaq:=1;

  Top:=19;  Bottom:=45; orr:=true;
  mult:=2;        { <--------------- This controls on the wobble size!}
  for imb := 0 to range do
  sins[imb] := round(sin(imb*pi/rang)*mult);
  s := seg(p^);
  o := ofs(p^);
  imb := 0;
  counter := 0;   { <--------------- This does NOT control on the wobble size!}
  yay := top;

 zoff:=zoff-26;
 xoff:=50;
   yoff:=250;

  repeat
   dec(yoff);
            for i:= 0 to 5 do
           begin
                pc:=pind[i];
                for j:=1 to 4 do
                begin
                     plg[j,1]:=px[polyst[pc,j-1]];
                     plg[j,2]:=py[polyst[pc,j-1]];
                end;
                fillpolygon(4,plg,0,s,true);
           end;

           for I := 0 to 7 do
           begin
                X1 := (Cosinus(PhiY)*Point[I,0]-Sinus(PhiY)*Point[I,2]) div 128;
                Y1 := (Cosinus(PhiZ)*Point[I,1]-Sinus(PhiZ)*X1) div 128;
                Z1 := (Cosinus(PhiY)*Point[I,2]+Sinus(PhiY)*Point[I,0]) div 128;
                X := (Cosinus(PhiZ)*X1+Sinus(PhiZ)*Point[I,1]) div 128;
                Y := (Cosinus(PhiX)*Y1+Sinus(PhiX)*Z1) div 128;
                Z := (Cosinus(Phix)*Z1-Sinus(Phix)*Y1) div 128;
                PX[I] := xoff+(Xc*Z-X*zoff) div (Z-Zc) ;     {store py}
                PY[I] := yoff+(Yc*Z-Y*zoff) div (Z-Zc) ;     {store px}
                PZ[I] := Z ;                                 {store pz}
           end;

           For I:=0 to nofpolys do
           begin
                polyz[I]:=pz[polyst[i,0]];          {add the zvalues of}
                polyz[I]:=Polyz[i]+pz[polyst[i,1]]; {the the points of }
                polyz[I]:=Polyz[i]+pz[polyst[i,2]]; {the triangle}
                polyz[I]:=Polyz[i]+pz[polyst[i,3]]; {the triangle}
                Pind[I]:=I;                         {index to point to Polygons}
           end;

           if shaq=0 then
              QuickSort( 0, 5); {sort the z-values of the polygones
                                 the farest triangle must be drawn first}

           inc(Phix,xstep);         {Rotate the axis}
           inc(Phiy,ystep);
           inc(PhiZ,Zstep);
           for i:= 0 to 5 do
           begin
                pc:=pind[i];
                for j:=1 to 4 do
                begin
                     plg[j,1]:=px[polyst[pc,j-1]];
                     plg[j,2]:=py[polyst[pc,j-1]];
                end;
                fillpolygon(4,plg,polcols[pc],s,false);
           end;

           flip(vad,vseg);

   until yoff = 115;


            shaq:=0;








{ zoff:=zoff-26;}
 xoff:=44;
{ yoff:=yoff+15;}
 CLRBOX(10,75,255,200);
                            showlines(082,10,' XLNET SITE ');
                            showlines(108,10,'24HRS ONLINE');
                            showlines(134,15,'14.4K MODEM');


           vvx:=1;
     repeat
           inc(vvv);
                      xoff:=xoff+vvx;
           for i:= 0 to 5 do
           begin
                pc:=pind[i];
                for j:=1 to 4 do
                begin
                     plg[j,1]:=px[polyst[pc,j-1]];
                     plg[j,2]:=py[polyst[pc,j-1]];
                end;
                fillpolygon(4,plg,0,s,true);
           end;

           for I := 0 to 7 do
           begin
                X1 := (Cosinus(PhiY)*Point[I,0]-Sinus(PhiY)*Point[I,2]) div 128;
                Y1 := (Cosinus(PhiZ)*Point[I,1]-Sinus(PhiZ)*X1) div 128;
                Z1 := (Cosinus(PhiY)*Point[I,2]+Sinus(PhiY)*Point[I,0]) div 128;
                X := (Cosinus(PhiZ)*X1+Sinus(PhiZ)*Point[I,1]) div 128;
                Y := (Cosinus(PhiX)*Y1+Sinus(PhiX)*Z1) div 128;
                Z := (Cosinus(Phix)*Z1-Sinus(Phix)*Y1) div 128;
                PX[I] := xoff+(Xc*Z-X*zoff) div (Z-Zc) ;     {store py}
                PY[I] := yoff+(Yc*Z-Y*zoff) div (Z-Zc) ;     {store px}
                PZ[I] := Z ;                                 {store pz}
           end;

           For I:=0 to nofpolys do
           begin
                polyz[I]:=pz[polyst[i,0]];          {add the zvalues of}
                polyz[I]:=Polyz[i]+pz[polyst[i,1]]; {the the points of }
                polyz[I]:=Polyz[i]+pz[polyst[i,2]]; {the triangle}
                polyz[I]:=Polyz[i]+pz[polyst[i,3]]; {the triangle}
                Pind[I]:=I;                         {index to point to Polygons}
           end;

           if shaq=0 then
              QuickSort( 0, 5); {sort the z-values of the polygones
                                 the farest triangle must be drawn first}

           inc(Phix,xstep);         {Rotate the axis}
           inc(Phiy,ystep);
           inc(PhiZ,Zstep);
           for i:= 0 to 5 do
           begin
                pc:=pind[i];
                for j:=1 to 4 do
                begin
                     plg[j,1]:=px[polyst[pc,j-1]];
                     plg[j,2]:=py[polyst[pc,j-1]];
                end;
                fillpolygon(4,plg,polcols[pc],s,false);
           end;

           flip(vad,vseg);

             Case vvv of
               226:     vvx:=0;
               228:     CLRBOX(10,75,212,165);
               286:     begin
                            showlines(082,84,'SYSOP......');
                            showlines(108,84,'RONEN PELEG');
                            showlines(134,89,'           ');

                        end;
               300:     vvx:=-1;
               513:     VVX:=0;
               568:     CLRBOX(10,75,255,200);
               569:     begin
                            showlines(082,10,' MANY PICS  ');
                            showlines(108,10,'ONLINE GAMES');
                            showlines(134,15,' NEW FILES ');
                        end;
               570:     vvx:=1;
               780:     vvx:=0;
               835:     CLRBOX(10,75,310,200);
               836:     begin
                            showlines(96,74,'JUST CALL');

                        end;
               837:     vvx:=-1;
              1050:     vvx:=0;

{
                               GetPlayerState (Info);
}
{
  if (HeadPTR <> TailPTR) then HeadPTR := TailPTR;
}
     end;
     until (keypressed) OR (vvv=1065);
     if keypressed then begin
                          ch:=readkey;
                          goto Jm1;
                        end;


  shaq:=1;
  repeat
  {
                   GetPlayerState (Info);
  }{
   if (HeadPTR <> TailPTR) then HeadPTR := TailPTR;
}
   inc(yoff);
            for i:= 0 to 5 do
           begin
                pc:=pind[i];
                for j:=1 to 4 do
                begin
                     plg[j,1]:=px[polyst[pc,j-1]];
                     plg[j,2]:=py[polyst[pc,j-1]];
                end;
                fillpolygon(4,plg,0,s,true);
           end;

           for I := 0 to 7 do
           begin
                X1 := (Cosinus(PhiY)*Point[I,0]-Sinus(PhiY)*Point[I,2]) div 128;
                Y1 := (Cosinus(PhiZ)*Point[I,1]-Sinus(PhiZ)*X1) div 128;
                Z1 := (Cosinus(PhiY)*Point[I,2]+Sinus(PhiY)*Point[I,0]) div 128;
                X := (Cosinus(PhiZ)*X1+Sinus(PhiZ)*Point[I,1]) div 128;
                Y := (Cosinus(PhiX)*Y1+Sinus(PhiX)*Z1) div 128;
                Z := (Cosinus(Phix)*Z1-Sinus(Phix)*Y1) div 128;
                PX[I] := xoff+(Xc*Z-X*zoff) div (Z-Zc) ;     {store py}
                PY[I] := yoff+(Yc*Z-Y*zoff) div (Z-Zc) ;     {store px}
                PZ[I] := Z ;                                 {store pz}
           end;

           For I:=0 to nofpolys do
           begin
                polyz[I]:=pz[polyst[i,0]];          {add the zvalues of}
                polyz[I]:=Polyz[i]+pz[polyst[i,1]]; {the the points of }
                polyz[I]:=Polyz[i]+pz[polyst[i,2]]; {the triangle}
                polyz[I]:=Polyz[i]+pz[polyst[i,3]]; {the triangle}
                Pind[I]:=I;                         {index to point to Polygons}
           end;

           if shaq=0 then
              QuickSort( 0, 5); {sort the z-values of the polygones
                                 the farest triangle must be drawn first}

           inc(Phix,xstep);         {Rotate the axis}
           inc(Phiy,ystep);
           inc(PhiZ,Zstep);
           for i:= 0 to 5 do
           begin
                pc:=pind[i];
                for j:=1 to 4 do
                begin
                     plg[j,1]:=px[polyst[pc,j-1]];
                     plg[j,2]:=py[polyst[pc,j-1]];
                end;
                fillpolygon(4,plg,polcols[pc],s,false);
           end;

           flip(vad,vseg);

   until yoff = 260;



     ShutDown;
     CLRBOX(10,75,212,165);



  getdata;
  randomize;
  bobbing := false;
  SBob := true;
  ShowPhone;
vvv:=0;

     repeat
{
                      GetPlayerState (Info);
}{
      if (HeadPTR <> TailPTR) then HeadPTR := TailPTR;
}

        Wobbler(top,bottom,mult);
        inc(vvv);
        inc(eee);
               if eee=3 then begin
                              eee:=0;
                              delay(1);
                             end;
        Case vvv of
           10:  Showphone;
          390:  grwrite ('CODING:',1, 70, 18);
         3960:  grwrite ('CiVAX',270,120,210);
        end;

     until keypressed;

jm1:

     freemem(p,64000);
     asm
        mov ax,3h
        int 10h
     end; Textcolor(15);
write ('INTRO CODED BY'); textcolor(11);write(' C');textcolor(3);write('i');textcolor(11);write('VAX');
textcolor(15);write(' ''94.  ');textcolor(7);writeln(' Also used:');
TextColor(9);write('3D rotating routines by');textcolor(10);writeln(' PLAVIUS');
textcolor(6);write('Player & Tune by');textcolor(12);writeln(' CHIKEN/ECR.');
textcolor(7);
     stopmusic;
end.